home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / emacs.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  7.8 KB  |  277 lines
  1. ;;;;     Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 2.1 of the License, or (at your option) any later version.
  7. ;;;; 
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;;;
  17. ;;;; The author can be reached at djurfeldt@nada.kth.se
  18. ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  19. ;;;; (I didn't write this!)
  20. ;;;;
  21.  
  22.  
  23. ;;; *********************************************************************
  24. ;;; * This is the Guile side of the Emacs interface                     *
  25. ;;; * Experimental hACK---the real version will be coming soon (almost) *
  26. ;;; *********************************************************************
  27.  
  28. ;;; {Session support for Emacs}
  29. ;;;
  30.  
  31. (define-module (ice-9 emacs)
  32.   :use-module (ice-9 debug)
  33.   :use-module (ice-9 threads)
  34.   :use-module (ice-9 session)
  35.   :no-backtrace)
  36.  
  37. (define emacs-escape-character #\sub)
  38.  
  39. (define emacs-output-port (current-output-port))
  40.  
  41. (define (make-emacs-command char)
  42.   (let ((cmd (list->string (list emacs-escape-character char))))
  43.     (lambda ()
  44.       (display cmd emacs-output-port))))
  45.  
  46. (define enter-input-wait  (make-emacs-command #\s))
  47. (define exit-input-wait   (make-emacs-command #\f))
  48. (define enter-read-character #\r)
  49. (define sending-error      (make-emacs-command #\F))
  50. (define sending-backtrace (make-emacs-command #\B))
  51. (define sending-result    (make-emacs-command #\x))
  52. (define end-of-text      (make-emacs-command #\.))
  53. (define no-stack      (make-emacs-command #\S))
  54. (define no-source      (make-emacs-command #\R))
  55.  
  56. ;; {Error handling}
  57. ;;
  58.  
  59. (add-hook! before-backtrace-hook sending-backtrace)
  60. (add-hook! after-backtrace-hook end-of-text)
  61. (add-hook! before-error-hook sending-error)
  62. (add-hook! after-error-hook end-of-text)
  63.  
  64. ;; {Repl}
  65. ;;
  66.  
  67. (set-current-error-port emacs-output-port)
  68.  
  69. (add-hook! before-read-hook
  70.        (lambda ()
  71.          (enter-input-wait)
  72.          (force-output emacs-output-port)))
  73.  
  74. (add-hook! after-read-hook
  75.        (lambda ()
  76.          (exit-input-wait)
  77.          (force-output emacs-output-port)))
  78.  
  79. ;;; {Misc.}
  80.  
  81. (define (make-emacs-load-port orig-port)
  82.   (letrec ((read-char-fn  (lambda args
  83.                 (let ((c (read-char orig-port)))
  84.                   (if (eq? c #\soh)
  85.                   (throw 'end-of-chunk)
  86.                   c)))))
  87.     
  88.     (make-soft-port
  89.      (vector #f #f #f
  90.          read-char-fn
  91.          (lambda () (close-port orig-port)))
  92.      "r")))
  93.  
  94. (set-current-input-port (make-emacs-load-port (current-input-port)))
  95.  
  96. (define (result-to-emacs exp)
  97.   (sending-result)
  98.   (write exp emacs-output-port)
  99.   (end-of-text)
  100.   (force-output emacs-output-port))
  101.  
  102. (define load-acknowledge (make-emacs-command #\l))
  103.  
  104. (define load-port (current-input-port))
  105.  
  106. (define (flush-line port)
  107.   (let loop ((c (read-char port)))
  108.     (if (not (eq? c #\nl))
  109.     (loop (read-char port)))))
  110.  
  111. (define whitespace-chars (list #\space #\tab #\nl #\np))
  112.  
  113. (define (flush-whitespace port)
  114.   (catch 'end-of-chunk
  115.      (lambda ()
  116.        (let loop ((c (read-char port)))
  117.          (cond ((eq? c the-eof-object)
  118.             (error "End of file while receiving Emacs data"))
  119.            ((memq c whitespace-chars) (loop (read-char port)))
  120.            ((eq? c #\;) (flush-line port) (loop (read-char port)))
  121.            (else (unread-char c port))))
  122.        #f)
  123.      (lambda args
  124.        (read-char port) ; Read final newline
  125.        #t)))
  126.  
  127. (define (emacs-load filename linum colnum module interactivep)
  128.   (define (read-and-eval! port)
  129.     (let ((x (read port)))
  130.       (if (eof-object? x)
  131.       (throw 'end-of-file)
  132.       (primitive-eval x))))
  133.   (set-port-filename! %%load-port filename)
  134.   (set-port-line! %%load-port linum)
  135.   (set-port-column! %%load-port colnum)
  136.   (lazy-catch #t
  137.           (lambda ()
  138.         (let loop ((endp (flush-whitespace %%load-port)))
  139.           (if (not endp)
  140.               (begin
  141.             (save-module-excursion
  142.              (lambda ()
  143.                (if module
  144.                    (set-current-module (resolve-module module #f)))
  145.                (let ((result
  146.                   (start-stack read-and-eval!
  147.                            (read-and-eval! %%load-port))))
  148.                  (if interactivep
  149.                  (result-to-emacs result)))))
  150.             (loop (flush-whitespace %%load-port)))
  151.               (begin
  152.             (load-acknowledge)))
  153.           (set-port-filename! %%load-port #f)))    ;reset port filename
  154.           (lambda (key . args)
  155.         (set-port-filename! %%load-port #f)
  156.         (cond ((eq? key 'end-of-chunk)
  157.                (fluid-set! the-last-stack #f)
  158.                (set! stack-saved? #t)
  159.                (scm-error 'misc-error
  160.                   #f
  161.                   "Incomplete expression"
  162.                   '()
  163.                   '()))
  164.               ((eq? key 'exit))
  165.               (else
  166.                (save-stack 2)
  167.                (catch 'end-of-chunk
  168.                   (lambda ()
  169.                 (let loop ()
  170.                   (read-char %%load-port)
  171.                   (loop)))
  172.                   (lambda args
  173.                 #f))
  174.                (apply throw key args))))))
  175.  
  176. (define (emacs-eval-request form)
  177.   (result-to-emacs (eval form (interaction-environment))))
  178.  
  179. ;;*fixme* Not necessary to use flags no-stack and no-source
  180. (define (get-frame-source frame)
  181.   (if (or (not (fluid-ref the-last-stack))
  182.       (>= frame (stack-length (fluid-ref the-last-stack))))
  183.       (begin
  184.     (no-stack)
  185.     #f)
  186.       (let* ((frame (stack-ref (fluid-ref the-last-stack)
  187.                    (frame-number->index frame)))
  188.          (source (frame-source frame)))
  189.     (or source
  190.         (begin (no-source)
  191.            #f)))))
  192.  
  193. (define (emacs-select-frame frame)
  194.   (let ((source (get-frame-source frame)))
  195.     (if source
  196.     (let ((fname (source-property source 'filename))
  197.           (line (source-property source 'line))
  198.           (column (source-property source 'column)))
  199.       (if (and fname line column)
  200.           (list fname line column)
  201.           (begin (no-source)
  202.              '())))
  203.     '())))
  204.  
  205. (define (object->string x . method)
  206.   (with-output-to-string
  207.     (lambda ()
  208.       ((if (null? method)
  209.        write
  210.        (car method))
  211.        x))))
  212.  
  213. (define (format template . rest)
  214.   (let loop ((chars (string->list template))
  215.          (result '())
  216.          (rest rest))
  217.     (cond ((null? chars) (list->string (reverse result)))
  218.       ((char=? (car chars) #\%)
  219.        (loop (cddr chars)
  220.          (append (reverse
  221.               (string->list
  222.                (case (cadr chars)
  223.                  ((#\S) (object->string (car rest)))
  224.                  ((#\s) (object->string (car rest) display)))))
  225.              result)
  226.          (cdr rest)))
  227.       (else (loop (cdr chars) (cons (car chars) result) rest)))))
  228.  
  229. (define (error-args->string args)
  230.   (let ((msg (apply format (caddr args) (cadddr args))))
  231.     (if (symbol? (cadr args))
  232.     (string-append (symbol->string (cadr args))
  233.                ": "
  234.                msg)
  235.     msg)))
  236.  
  237. (define (emacs-frame-eval frame form)
  238.   (let ((source (get-frame-source frame)))
  239.     (if source
  240.     (catch #t
  241.            (lambda ()
  242.          (list 'result
  243.                (object->string
  244.             (local-eval (with-input-from-string form read)
  245.                     (memoized-environment source)))))
  246.            (lambda args
  247.          (list (car args)
  248.                (error-args->string args))))
  249.     (begin
  250.       (no-source)
  251.       '()))))
  252.  
  253. (define (emacs-symdoc symbol)
  254.   (if (or (not (module-bound? (current-module) symbol))
  255.       (not (procedure? (eval symbol (interaction-environment)))))
  256.       'nil
  257.       (procedure-documentation (eval symbol (interaction-environment)))))
  258.  
  259. ;;; A fix to get the emacs interface to work together with the module system.
  260. ;;;
  261. (for-each (lambda (name value)
  262.         (module-define! the-root-module name value))
  263.       '(%%load-port
  264.         %%emacs-load
  265.         %%emacs-eval-request
  266.         %%emacs-select-frame
  267.         %%emacs-frame-eval
  268.         %%emacs-symdoc
  269.         %%apropos-internal)
  270.       (list load-port
  271.         emacs-load
  272.         emacs-eval-request
  273.         emacs-select-frame
  274.         emacs-frame-eval
  275.         emacs-symdoc
  276.         apropos-internal))
  277.